perm filename PCODE.SAI[PNT,HE]1 blob
sn#466140 filedate 1979-08-13 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00013 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 ENTRY
C00004 00003 ! buffer definitions, ipush,fpush,gpush,ppush,cpush
C00006 00004 ! αexpr$,βexpr$,nexpr,expr$11,expr$2,expr$off
C00011 00005 ! frcpcode
C00013 00006 ! pdp10 routines: $afxpcode,$ufxpcode,$asgpcode,$coordpcode
C00016 00007 ! printing: prnpcode,prvpcode,abortpcode,promptpcode,ddt
C00018 00008 ! motion:$centerpcode,$movepcode,$drivepcode
C00022 00009 ! wrist,setbase,gather,rforce,setstf
C00023 00010 ! control pcodes: if,for,while,do
C00026 00011 ! cobegpcode
C00028 00012 ! arrdclpcode,prcdclpcode,rtnpcode,smpdclpcode
C00032 00013 ! vt05pcode
C00033 ENDMK
C⊗;
ENTRY;
BEGIN "PCODE"
COMMENT Module which produces the pcode interpretation of the
relevant instructions ;
DEFINE $$PRGID=TRUE; DEFINE $PCODE=TRUE;
REQUIRE "HEADER.SAI" SOURCE_FILE;
! buffer definitions, ipush,fpush,gpush,ppush,cpush;
INTEGER ARRAY $BUFFER[1:1000];
INTEGER $BUFFERPTR;
! pushes integer J into the buffer ;
SIMPLE PROCEDURE IPUSH(INTEGER J);
$BUFFER[$BUFFERPTR←$BUFFERPTR+1]←J;
! pushes 11 representation of real value R into buffer ;
SIMPLE PROCEDURE FPUSH(REAL R);
BEGIN
FLTOUT(R,$BUFFER[$BUFFERPTR+1],$BUFFER[$BUFFERPTR+2]);
$BUFFERPTR←$BUFFERPTR+2;
END;
! pushes code to do a gtval ;
PROCEDURE GPUSH(RPTR(SYMBOL)S);
BEGIN INTEGER I;
IF SYMBOL:INDEX[S]>0
THEN FOR I←XAGTVAL,SYMBOL:INDEX[S],SYMBOL:OFFSET[S] DO IPUSH(I)
ELSE FOR I←XGTVAL,SYMBOL:OFFSET[S] DO IPUSH(I);
END;
PROCEDURE CPUSH(RPTR(SYMBOL)S);
BEGIN INTEGER I;
IF SYMBOL:INDEX[S]>0
THEN FOR I←XACHNGE,SYMBOL:INDEX[S],SYMBOL:OFFSET[S] DO IPUSH(I)
ELSE FOR I←XCHNGE,SYMBOL:OFFSET[S] DO IPUSH(I);
END;
PROCEDURE PPUSH(RPTR(SYMBOL)S);
IF SYMBOL:INDEX[S]>0 THEN
BEGIN IPUSH(XPUSHINTI);IPUSH(SYMBOL:INDEX[S]); END;
! αexpr$,βexpr$,nexpr,expr$11,expr$2,expr$off;
RPTR (EXPR$)PROCEDURE βEXPR$(INTEGER TYPE(0));
BEGIN
! creates a record EXPR$ with data from the buffer $BUFFER;
RPTR(EXPR$)EE; INTEGER ARRAY BUFF[1:$BUFFERPTR];
ARRBLT(BUFF[1],$BUFFER[1],$BUFFERPTR);
EE←NEW_RECORD(EXPR$);
MEMORY[LOCATION(EXPR$:BODY[EE])]↔MEMORY[LOCATION(BUFF)];
EXPR$:#BODY[EE]←$BUFFERPTR;
EXPR$:TYPE[EE]←TYPE;
$BUFFERPTR←0;
RETURN(EE);
END;
RPTR(EXPR$)PROCEDURE NEXPR(INTEGER SIZE,ARG1);
BEGIN
! produces a record EXPR$ with #BODY=SIZE, and first element=ARG1;
INTEGER ARRAY BUFF[1:SIZE];
RPTR(EXPR$)EE;
BUFF[1]←ARG1;
EE←NEW_RECORD(EXPR$);
EXPR$:#BODY[EE]←SIZE;
MEMORY[LOCATION(EXPR$:BODY[EE])]↔MEMORY[LOCATION(BUFF)];
RETURN(EE);
END;
INTERNAL RPTR(EXPR$)PROCEDURE EXPR$1(INTEGER I(0));
RETURN(NEXPR(1,I));
INTERNAL RPTR(EXPR$)PROCEDURE EXPR$2(INTEGER I(0),J(0));
BEGIN
RPTR(EXPR$)E;
E←NEXPR(2,I);
EXPR$:BODY[E][2]←J;
RETURN(E);
END;
INTERNAL RPTR(EXPR$)PROCEDURE EXPR$3(INTEGER I(0),J(0),K(0));
BEGIN
RPTR(EXPR$)E;
E←NEXPR(3,I);
EXPR$:BODY[E][2]←J;
EXPR$:BODY[E][3]←K;
RETURN(E);
END;
INTEGER PROCEDURE EXPR$OFF(RPTR(EXPR$)ARRAY ARR; INTEGER I,J);
BEGIN
INTEGER K,K1;
K←1;
FOR K1←I STEP 1 UNTIL J DO IF ARR[K1] THEN K←K+EXPR$:#BODY[ARR[K1]];
RETURN(K);
END;
INTERNAL RPTR(EXPR$)PROCEDURE EXPR$R(RPTR(SYMBOL)S);
IF SYMBOL:ACCESS[S]=#ARRAY_ELEMENT THEN
BEGIN
RPTR(SYMBOL)S1;
RPTR(EXPR$)E;
STRING SAVTOKEN; BOOLEAN SAVSTOKEN;
SAVTOKEN←TOKEN; SAVSTOKEN←STOKEN;
STOKEN←FALSE;
ASKUSER(SYMBOL:PNAME[S]&";");
E←IDREF(S1);
TOKEN←SAVTOKEN;STOKEN←SAVSTOKEN; ! this destroys the semicolon ;
RETURN($APPEND(E,EXPR$2(XGVALS,XRTVAL)));
END ELSE
IF SYMBOL:INDEX[S]>0
THEN RETURN(EXPR$3(XARTVAL,SYMBOL:INDEX[S],SYMBOL:OFFSET[S]))
ELSE IF SYMBOL:OFFSET[S]<'1000
THEN RETURN(EXPR$3(XGTVAL,SYMBOL:OFFSET[S],XRTVAL))
ELSE RETURN(EXPR$1(XNOOP));
INTERNAL RPTR(EXPR$) PROCEDURE EXPR$G(RPTR(SYMBOL)S);
IF SYMBOL:ACCESS[S]=#ARRAY_ELEMENT THEN
BEGIN
RPTR(SYMBOL)S1;
RPTR(EXPR$)E;
ASKUSER(SYMBOL:PNAME[S]&";");
E←IDREF(S1);
STOKEN←FALSE; ! destroy the semicolon;
RETURN($APPEND(E,EXPR$1(XGVALS)));
END ELSE
IF SYMBOL:INDEX[S]>0
THEN RETURN(EXPR$3(XAGTVAL,SYMBOL:INDEX[S],SYMBOL:OFFSET[S]))
ELSE IF SYMBOL:OFFSET[S]<'1000
THEN RETURN(EXPR$2(XGTVAL,SYMBOL:OFFSET[S]))
ELSE RETURN(EXPR$1(XNOOP));
INTERNAL RPTR (EXPR$) PROCEDURE αEXPR$(INTEGER ARRAY BUFFER;INTEGER #TYPE);
BEGIN
! creates a record EXPR$ with data the contents of BUFFER;
RPTR(EXPR$) EE; INTEGER I;
I←ARRINFO(BUFFER,2);
BEGIN
INTEGER ARRAY BUFF[1:I];
ARRTRAN(BUFF,BUFFER);
EE←NEW_RECORD(EXPR$);
MEMORY[LOCATION(EXPR$:BODY[EE])]↔MEMORY[LOCATION(BUFF)];
EXPR$:#BODY[EE]←I;
END;
EXPR$:TYPE[EE]←#TYPE;
RETURN(EE);
END;
! frcpcode;
INTERNAL RPTR(EXPR$)PROCEDURE $FRCPCODE(RPTR(EXPR$)E,EXP;INTEGER BITS,DEVBITS);
BEGIN
RPTR(EXPR$)ARRAY F[1:10]; RPTR(SYMBOL)C; INTEGER I,IPC;
F[1]←EXPR$2(XGTBLK);
F[2]←EXPR$3(XAGTVAL,SYMBOL:INDEX[C←CHECK("NILTRANS",#TR)],
SYMBOL:OFFSET[C]); ! expression for trans;
F[3]←EXPR$2(XTFRCST,DEVBITS);
F[4]←EXP;
F[5]←EXPR$2(XCMFORCE,XCMDONE);
EXPR$:BODY[F[1]][2]←EXPR$OFF(F,2,5)-1;
IPC←-1;
F[6]←EXPR$1(5); ! insert it into 5 places from here;
FOR I←XMVAR,5,1,3,IPC,0,BITS,0 DO IPUSH(I);
F[7]←βEXPR$;
F[8]←EXPR$2(XCMENBL,$TMPOFF);
F[9]←E;
F[10]←EXPR$2(XCMDSBL,$TMPOFF);
RETURN($AAPPEND(F));
END;
! pdp10 routines: $afxpcode,$ufxpcode,$asgpcode,$coordpcode;
INTERNAL RPTR(EXPR$) PROCEDURE $AFXPCODE(RPTR(EXPR$)SON,DAD; INTEGER AFFTYPE;
RPTR(EXPR$)E1);
BEGIN
INTEGER AFFCODE;
RPTR(EXPR$)EE; RPTR(EXPR$) ARRAY E[1:4];
AFFCODE←IF AFFTYPE≠#RGDLK THEN #NONRGD ELSE 0;
IF E1 THEN E[1]←E1
ELSE BEGIN E[1]←EXPR$1(XNOOP);AFFCODE←AFFCODE+'100000; END;
E[2]←DAD;
E[3]←SON;
E[4]←EXPR$2(XPAFFIX,AFFCODE);
EE←$AAPPEND(E);
RETURN(EE);
END;
INTERNAL RPTR(EXPR$) PROCEDURE $UFXPCODE(RPTR(EXPR$)S,D);
BEGIN RPTR(EXPR$)ARRAY E[1:3];
E[1]←D;
E[2]←S;
E[3]←EXPR$1(XPUNFIX);
RETURN($AAPPEND(E));
END;
INTERNAL RPTR(EXPR$) PROCEDURE $ASGPCODE(RPTR(EXPR$) EXPR; RPTR(SYMBOL)S);
BEGIN
RPTR(EXPR$)ARRAY PTR[1:2];
RPTR(EXPR$)E2; INTEGER TYPE;
PTR[1]←EXPR; ! compute the expression ;
CPUSH(S);
PTR[2]←βEXPR$(TYPE←SYMBOL:TYPE[S]); ! assign the variable ;
$DISPLAYLIST[TYPE]←NULL;
RETURN($AAPPEND(PTR,TYPE));
END;
INTERNAL RPTR(EXPR$) PROCEDURE $AASGPCODE(RPTR(EXPR$)E1,E2);
BEGIN
RPTR(EXPR$)ARRAY PTR[1:2];
PTR[1]←E2; ! compute the expression ;
PTR[2]←E1; ! assign the variable ;
RETURN($AAPPEND(PTR));
END;
INTERNAL RPTR(EXPR$) PROCEDURE $COORDPCODE(RPTR(EXPR$)E1,E2; INTEGER ELEMENT,TYPE);
BEGIN
RPTR(EXPR$)ARRAY PTR[1:3];
PTR[1]←E2; ! compute the value;
PTR[2]←E1; ! put reference of id on the interpreter stack;
CASE TYPE OF
BEGIN
[#SC] PTR[3]←EXPR$2(XCHCMP,ELEMENT);
[#VT] PTR[3]←EXPR$1(XCHTPOS);
[#RT] PTR[3]←EXPR$1(XCHTORIENT)
END;
RETURN($AAPPEND(PTR));
END;
! printing: prnpcode,prvpcode,abortpcode,promptpcode,ddt;
INTERNAL RPTR(EXPR$) PROCEDURE $PRVPCODE(RPTR(EXPR$)E);
RETURN($APPEND(E,EXPR$1(XVALPRN),EXPR$:TYPE[E]));
! used to be
RETURN($APPEND(E,EXPR$2(XPRVAL,EXPR$:TYPE[E]),EXPR$:TYPE[E]));
INTERNAL RPTR(EXPR$)PROCEDURE $PRNPCODE(STRING S);
BEGIN
RPTR(EXPR$) ARRAY PRN[1:3]; INTEGER I;
PRN[1]←EXPR$2(XRJMP);
DO IPUSH(LOP(S)+ (I←LOP(S)) LSH 8) UNTIL I=0;
PRN[2]←βEXPR$;
PRN[3]←EXPR$2(XRPRINT);
EXPR$:BODY[PRN[1]][2]←EXPR$OFF(PRN,2,2);
EXPR$:BODY[PRN[3]][2]←-EXPR$OFF(PRN,2,2);
RETURN($AAPPEND(PRN));
END;
INTERNAL RPTR(EXPR$)PROCEDURE $ABORTPCODE;
RETURN(EXPR$1(XABORT));
INTERNAL RPTR(EXPR$)PROCEDURE $PROMPTPCODE;
RETURN(EXPR$1(XPROMPT));
INTERNAL RPTR(EXPR$) PROCEDURE $DDTPCODE;
RETURN(EXPR$1(XDDT));
! motion:$centerpcode,$movepcode,$drivepcode;
PRESET_WITH '100000,'40000,'20000,'10000,'4000,'2000,'1000,
'400,'200,'100,'40,'20,'10,'4;
INTEGER ARRAY JT_CODE[0:1,1:7];
INTERNAL RPTR(EXPR$)PROCEDURE $DRIVEPCODE(INTEGER COLOR;STRING HOW;
INTEGER JOINT;RPTR(EXPR$)SCAL);
BEGIN RPTR(EXPR$)E;
INTEGER I;
FOR I←XCHNGE,$TSCOFF,XRJMP,9,
JT_CODE[COLOR,JOINT],0,0,0, $TSCOFF,0,0,0,
(IF EQU(HOW,"BY") THEN XRTDDRIVE ELSE XRTADRIVE),
-9,
(IF 1≤JOINT≤6
THEN IF COLOR=BLUE THEN BARM_MECH
ELSE YARM_MECH
ELSE IF COLOR=BLUE THEN BHAND_MECH
ELSE YHAND_MECH)
DO IPUSH(I);
E←$APPEND(SCAL,βEXPR$);
RETURN(E);
END;
INTERNAL RPTR(EXPR$)PROCEDURE $MOVEPCODE(RPTR(SYMBOL)S1,S2;
RPTR(EXPR$)ARRAY FDESTS; INTEGER NFDEST);
BEGIN
RPTR(EXPR$) ARRAY BDESTS[0:NFDEST],PTR[1:4];
RPTR(EXPR$) PPTR;
INTEGER I,J,INDEX;
J←$TTROFF;
GPUSH(S1);
IPUSH(XTINVRT);
GPUSH(S2);
FOR I← XTTMUL,
XCHNGE, J
DO IPUSH(I);
BDESTS[0]←βEXPR$;
FOR I←1 STEP 1 UNTIL NFDEST
DO BEGIN INTEGER I1;
FOR I1←XGTVAL,J,XTTMUL, XCHNGE,J+I DO IPUSH(I1);
BDESTS[I]←$APPEND(FDESTS[I],βEXPR$,0);
END;
PTR[1]←$AAPPEND(BDESTS);
PTR[2]←EXPR$2(XRJMP);
FOR I←BARMSB,0,0,0 DO IPUSH(I);
FOR I←1 STEP 1 UNTIL NFDEST DO
BEGIN
IPUSH(J+I); IPUSH(0);IPUSH(0)
END;
IPUSH(0);
PTR[3]←βEXPR$;
EXPR$:BODY[PTR[2]][2]←EXPR$OFF(PTR,3,3);
FOR I←XRPMOVE, - (EXPR$:#BODY[PTR[3]]+1),
BARM_MECH
DO IPUSH(I);
PTR[4]←βEXPR$;
PPTR←$AAPPEND(PTR);
RETURN(PPTR);
END;
INTERNAL RPTR(EXPR$) PROCEDURE $CENTERPCODE(INTEGER ARM);
BEGIN "CENTER"
INTEGER I;
RPTR(EXPR$) PTR;
FOR I←XRJMP,8,
(IF ARM=BLUE THEN (BARMSB+BHANDSB) ELSE (YHANDSB+YARMSB)),
0,0,0,0,0,0,
XRCENTER,- 8,
(IF ARM=BLUE THEN BARM_MECH+BHAND_MECH ELSE YARM_MECH+YHAND_MECH)
DO IPUSH(I);
PTR←βEXPR$;
RETURN(PTR);
END "CENTER";
! wrist,setbase,gather,rforce,setstf;
INTERNAL RPTR(EXPR$)PROCEDURE $WRISTPCODE(RPTR(SYMBOL)S);
RETURN(EXPR$2(XWRIST,SYMBOL:OFFSET[S]));
INTERNAL RPTR(EXPR$)PROCEDURE $SETBASEPCODE;
RETURN(EXPR$1(XSETBAS));
INTERNAL RPTR(EXPR$)PROCEDURE $GATHERPCODE(INTEGER STATUS);
RETURN(EXPR$2(XGATHER,STATUS));
INTERNAL RPTR(EXPR$) PROCEDURE $RFORCEPCODE;
RETURN(EXPR$1(XRFORCE));
INTERNAL RPTR(EXPR$)PROCEDURE $SETSTFPCODE;
RETURN(EXPR$1(XSETSTF));
! control pcodes: if,for,while,do;
INTERNAL RPTR(EXPR$)PROCEDURE $IFPCODE(RPTR(EXPR$) COND,A,B(NULL));
BEGIN
RPTR(EXPR$)ARRAY IFP[1:6];
IFP[1]←COND;
IFP[2]←EXPR$2(XRJMPC);
IFP[3]←A;
IFP[4]←EXPR$2(XRJMP);
IFP[5]←IF B THEN B ELSE EXPR$1(XNOOP);
IFP[6]←EXPR$1(XNOOP);
EXPR$:BODY[IFP[2]][2]←EXPR$OFF(IFP,3,4);
EXPR$:BODY[IFP[4]][2]←EXPR$OFF(IFP,5,5);
RETURN($AAPPEND(IFP));
END;
INTERNAL RPTR(EXPR$)PROCEDURE $WHILEPCODE(RPTR(EXPR$)COND,STAT);
BEGIN
RPTR(EXPR$)ARRAY WHP[1:5];
WHP[1]←COND;
WHP[2]←EXPR$2(XRJMPC);
WHP[3]←STAT;
WHP[4]←EXPR$2(XRJMP);
WHP[5]←EXPR$1(XNOOP);
EXPR$:BODY[WHP[2]][2]←EXPR$OFF(WHP,3,4);
EXPR$:BODY[WHP[4]][2]←-EXPR$OFF(WHP,1,3);
RETURN($AAPPEND(WHP));
END;
INTERNAL RPTR(EXPR$)PROCEDURE $DOPCODE(RPTR(EXPR$)S,B);
BEGIN
RPTR(EXPR$)ARRAY DOP[1:3];
DOP[1]←S;
DOP[2]←B;
DOP[3]←EXPR$2(XRJMPC,-EXPR$OFF(DOP,1,2));
RETURN($AAPPEND(DOP));
END;
INTERNAL RPTR(EXPR$)PROCEDURE $FORPCODE(RPTR(SYMBOL)K;RPTR(EXPR$)I1,I2,I3,S);
BEGIN
RPTR(EXPR$) ARRAY FORP[1:9]; INTEGER I;
FORP[1]←I1;
FORP[2]←I3;
FORP[3]←I2;
FOR I←XCOPY,2 DO IPUSH(I);
CPUSH(K);
FORP[4]←βEXPR$;
FORP[5]←EXPR$2(XRFRCHK);
FORP[6]←S;
FOR I←XCOPY,0,XCOPY,3,XSADD,XREPLAC,3 DO IPUSH(I);
FORP[7]←βEXPR$;
FORP[8]←EXPR$2(XRJMP);
FORP[9]←EXPR$3(XPOP,XPOP,XPOP);
EXPR$:BODY[FORP[8]][2]←-EXPR$OFF(FORP,4,7);
EXPR$:BODY[FORP[5]][2]←EXPR$OFF(FORP,6,8);
RETURN($AAPPEND(FORP));
END;
! cobegpcode;
INTERNAL RPTR(EXPR$)PROCEDURE $COBEGPCODE(RPTR(EXPR$)ARRAY STATEMENTS);
BEGIN ! outputting the following:
0$: RJMP $X-0$-1
1$: STATEMENT 1
TERMINATE
2$: STATEMENT 2
TERMINATE
...
N$: STATEMENT N
TERMINATE
$X: XSPROUT
$X+1: N (i.e. # of statements)
$Y: 1$-$Y
0
2$-$Y
0
..
N$-$Y
0
0
;
RPTR(EXPR$) ARRAY PTR[0:ARRINFO(STATEMENTS,2)+1];
RPTR(EXPR$) E;
INTEGER #ARRSIZE,I;
#ARRSIZE←ARRINFO(STATEMENTS,2);
FOR I←1 STEP 1 UNTIL #ARRSIZE
DO PTR[I]←$APPEND(STATEMENTS[I],EXPR$1(XTERMINATE));
E←PTR[#ARRSIZE+1]←NEXPR(#ARRSIZE*2+3,XPSPROUT);
EXPR$:BODY[E][2]←#ARRSIZE;
FOR I←1 STEP 1 UNTIL #ARRSIZE
DO EXPR$:BODY[E][2*I+1]←-EXPR$OFF(PTR,I,#ARRSIZE)-1;
PTR[0]←EXPR$2(XRJMP,EXPR$OFF(PTR,1,#ARRSIZE));
RETURN($AAPPEND(PTR));
END;
! arrdclpcode,prcdclpcode,rtnpcode,smpdclpcode;
INTERNAL RPTR(EXPR$)PROCEDURE $SMPDCLPCODE(INTEGER OBTYPE,J);
BEGIN
INTEGER I;
FOR I←XMVAR, OBTYPES[OBTYPE], J, 0 DO IPUSH(I);
RETURN(βEXPR$(OBTYPE));
END;
INTERNAL RPTR(EXPR$)PROCEDURE $KVARPCODE(INTEGER N);
IF N>0 THEN RETURN(EXPR$2(XKVAR,N)) ELSE RETURN(EXPR$1(XNOOP));
INTERNAL RPTR(EXPR$)PROCEDURE $RTNPCODE(RPTR(EXPR$)EE);
BEGIN
RPTR(EXPR$)E;
INTEGER I,TYP,VAL;
IF EE=NULL!RECORD THEN
BEGIN VAL←0; TYP←#PR END
ELSE BEGIN VAL←#MINUS1; TYP←EXPR$:TYPE[EE]; END;
FOR I←XRETURN,VAL DO IPUSH(I);
E←βEXPR$;
E←$APPEND(EE,E,TYP);
RETURN(E);
END;
INTERNAL RPTR(EXPR$)PROCEDURE $PRCDCLPCODE(RPTR(SYMBOL)SYM; RPTR(EXPR$)PBODY);
BEGIN
INTEGER NARGS,ENV;
RPTR(EXPR$) ARRAY PTR[1:5];
RPTR(EXPR$)PPTR;
RPTR(PROC)P;
INTEGER I,IPC;
INTEGER OBTYPE;
OBTYPE←SYMBOL:TYPE[SYM];
NARGS←PROC:NARGS[P←SYMBOL:OBJECT[SYM]];
ENV←NARGS; ! include the local variables too ;
IPC← - 1 ; ! dummy to get PPCODE to print out ;
PTR[1]←EXPR$2(XGTBLK);
PTR[2]←PBODY;
PTR[3]←EXPR$2(XRETURN);
IF SYMBOL:TYPE[CURPROC]≠#PR THEN EXPR$:BODY[PTR[3]][2]←#MINUS1;
EXPR$:BODY[PTR[1]][2]←EXPR$OFF(PTR,2,3)-1;
PTR[4]←EXPR$1(5);
FOR I←XMVAR,#PRCTYP,1,NARGS,IPC,ENV+30 DO IPUSH(I);
FOR I←1 STEP 1 UNTIL NARGS DO IPUSH(PROC:ARGACCS[P][I]
+OBTYPES[PROC:ARGTYPE[P][I]]);
IPUSH(0); ! indicate end of mvar pcode;
PTR[5]←βEXPR$(OBTYPE); ! this is the procedure header ;
PPTR←$AAPPEND(PTR);
RETURN(PPTR);
END;
INTERNAL RPTR(EXPR$) PROCEDURE $ARRDCLPCODE(RPTR(EXPR$)ARRAY BOUNDS;
INTEGER OBTYPE,ADIM,OFFSET);
BEGIN
RPTR(EXPR$) ARRAY $BOUNDS[1:4*ADIM+1];
RPTR(EXPR$) PTR; RPTR(SYMBOL)S; RPTR(ARRAYREC)A;
INTEGER I,I1,I2,J;
J←$TSCOFF-1; I2←0;
FOR I←1 STEP 1 UNTIL 2*ADIM DO
BEGIN
$BOUNDS[I2←I2+1]←BOUNDS[I];
FOR I1←XCHNGE,J+I DO IPUSH(I1);
$BOUNDS[I2←I2+1]←βEXPR$;
END;
FOR I1←XMVAR,#ARRTYP + OBTYPES[OBTYPE],ADIM DO IPUSH(I1);
FOR I1←2 STEP 2 UNTIL ADIM*2 DO BEGIN IPUSH(J+I1); IPUSH(J+I1-1); END;
IPUSH(0);
FOR I1←XARRINI,OFFSET DO IPUSH(I1);
$BOUNDS[I2←I2+1]←βEXPR$;
PTR←$AAPPEND($BOUNDS,OBTYPE);
RETURN(PTR);
END;
! vt05pcode;
INTERNAL RPTR(EXPR$) PROCEDURE $VT05PCODE(INTEGER STATE);
RETURN(EXPR$2(XDISVT05,STATE));
END "PCODE";